home *** CD-ROM | disk | FTP | other *** search
/ HyperLib 1997 Winter - Disc 1 / HYPERLIB-1997-Winter-CD1.ISO.7z / HYPERLIB-1997-Winter-CD1.ISO / オンラインウェア / PRG / Mac_F2C_1.3.2.sit / Mac F2C 1.3.2 / Mac F2C Libraries / libI77 Sources / lwrite.c < prev    next >
C/C++ Source or Header  |  1995-01-28  |  4KB  |  277 lines
  1. #include "f2c.h"
  2. #include "fio.h"
  3. #include "fmt.h"
  4. #include "lio.h"
  5. ftnint L_len;
  6.  
  7.  static VOID
  8. donewrec(Void)
  9. {
  10.     if (f__recpos)
  11.         (*f__donewrec)();
  12.     }
  13.  
  14. #ifdef KR_headers
  15. t_putc(c)
  16. #else
  17. t_putc(int c)
  18. #endif
  19. {
  20.     f__recpos++;
  21.     putc(c,f__cf);
  22.     return(0);
  23. }
  24.  static VOID
  25. #ifdef KR_headers
  26. lwrt_I(n) long n;
  27. #else
  28. lwrt_I(long n)
  29. #endif
  30. {
  31.     char buf[LINTW],*p;
  32. #ifdef USE_STRLEN
  33.     (void) sprintf(buf," %ld",n);
  34.     if(f__recpos+strlen(buf)>=L_len)
  35. #else
  36.     if(f__recpos + sprintf(buf," %ld",n) >= L_len)
  37. #endif
  38.         donewrec();
  39.     for(p=buf;*p;PUT(*p++));
  40. }
  41.  static VOID
  42. #ifdef KR_headers
  43. lwrt_L(n, len) ftnint n; ftnlen len;
  44. #else
  45. lwrt_L(ftnint n, ftnlen len)
  46. #endif
  47. {
  48.     if(f__recpos+LLOGW>=L_len)
  49.         donewrec();
  50.     wrt_L((Uint *)&n,LLOGW, len);
  51. }
  52.  static VOID
  53. #ifdef KR_headers
  54. lwrt_A(p,len) char *p; ftnlen len;
  55. #else
  56. lwrt_A(char *p, ftnlen len)
  57. #endif
  58. {
  59.     int i;
  60.     if(f__recpos+len>=L_len)
  61.         donewrec();
  62. #ifndef OMIT_BLANK_CC
  63.     if (!f__recpos)
  64.         PUT(' ');
  65. #endif
  66.     for(i=0;i<len;i++) PUT(*p++);
  67. }
  68.  
  69.  static int
  70. #ifdef KR_headers
  71. l_g(buf, n) char *buf; double n;
  72. #else
  73. l_g(char *buf, double n)
  74. #endif
  75. {
  76. #ifdef Old_list_output
  77.     doublereal absn;
  78.     char *fmt;
  79.  
  80.     absn = n;
  81.     if (absn < 0)
  82.         absn = -absn;
  83.     fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT;
  84. #ifdef USE_STRLEN
  85.     sprintf(buf, fmt, n);
  86.     return strlen(buf);
  87. #else
  88.     return sprintf(buf, fmt, n);
  89. #endif
  90.  
  91. #else
  92.     register char *b, c, c1;
  93.  
  94.     b = buf;
  95.     *b++ = ' ';
  96.     if (n < 0) {
  97.         *b++ = '-';
  98.         n = -n;
  99.         }
  100.     else
  101.         *b++ = ' ';
  102.     if (n == 0) {
  103.         *b++ = '0';
  104.         *b++ = '.';
  105.         *b = 0;
  106.         goto f__ret;
  107.         }
  108.     sprintf(b, LGFMT, n);
  109.     switch(*b) {
  110.         case '0':
  111.             while(b[0] = b[1])
  112.                 b++;
  113.             break;
  114.         case 'i':
  115.         case 'I':
  116.             /* Infinity */
  117.         case 'n':
  118.         case 'N':
  119.             /* NaN */
  120.             while(*++b);
  121.             break;
  122.  
  123.         default:
  124.     /* Fortran 77 insists on having a decimal point... */
  125.             for(;; b++)
  126.             switch(*b) {
  127.             case 0:
  128.                 *b++ = '.';
  129.                 *b = 0;
  130.                 goto f__ret;
  131.             case '.':
  132.                 while(*++b);
  133.                 goto f__ret;
  134.             case 'E':
  135.                 for(c1 = '.', c = 'E';  *b = c1;
  136.                     c1 = c, c = *++b);
  137.                 goto f__ret;
  138.             }
  139.         }
  140.  f__ret:
  141.     return b - buf;
  142. #endif
  143.     }
  144.  
  145.  static VOID
  146. #ifdef KR_headers
  147. l_put(s) register char *s;
  148. #else
  149. l_put(register char *s)
  150. #endif
  151. {
  152. #ifdef KR_headers
  153.     register int c, (*pn)() = f__putn;
  154. #else
  155.     register int c, (*pn)(int) = f__putn;
  156. #endif
  157.     while(c = *s++)
  158.         (*pn)(c);
  159.     }
  160.  
  161.  static VOID
  162. #ifdef KR_headers
  163. lwrt_F(n) double n;
  164. #else
  165. lwrt_F(double n)
  166. #endif
  167. {
  168.     char buf[LEFBL];
  169.  
  170.     if(f__recpos + l_g(buf,n) >= L_len)
  171.         donewrec();
  172.     l_put(buf);
  173. }
  174.  static VOID
  175. #ifdef KR_headers
  176. lwrt_C(a,b) double a,b;
  177. #else
  178. lwrt_C(double a, double b)
  179. #endif
  180. {
  181.     char *ba, *bb, bufa[LEFBL], bufb[LEFBL];
  182.     int al, bl;
  183.  
  184.     al = l_g(bufa, a);
  185.     for(ba = bufa; *ba == ' '; ba++)
  186.         --al;
  187.     bl = l_g(bufb, b) + 1;    /* intentionally high by 1 */
  188.     for(bb = bufb; *bb == ' '; bb++)
  189.         --bl;
  190.     if(f__recpos + al + bl + 3 >= L_len)
  191.         donewrec();
  192. #ifdef OMIT_BLANK_CC
  193.     else
  194. #endif
  195.     PUT(' ');
  196.     PUT('(');
  197.     l_put(ba);
  198.     PUT(',');
  199.     if (f__recpos + bl >= L_len) {
  200.         (*f__donewrec)();
  201. #ifndef OMIT_BLANK_CC
  202.         PUT(' ');
  203. #endif
  204.         }
  205.     l_put(bb);
  206.     PUT(')');
  207. }
  208. #ifdef KR_headers
  209. l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
  210. #else
  211. l_write(ftnint *number, char *ptr, ftnlen len, ftnint type)
  212. #endif
  213. {
  214. #define Ptr ((flex *)ptr)
  215.     int i;
  216.     long x;
  217.     double y,z;
  218.     real *xx;
  219.     doublereal *yy;
  220.     for(i=0;i< *number; i++)
  221.     {
  222.         switch((int)type)
  223.         {
  224.         default: f__fatal(204,"unknown type in lio");
  225.         case TYINT1:
  226.             x = Ptr->flchar;
  227.             goto xint;
  228.         case TYSHORT:
  229.             x=Ptr->flshort;
  230.             goto xint;
  231. #ifdef TYQUAD
  232.         case TYQUAD:
  233.             x = Ptr->fllongint;
  234.             goto xint;
  235. #endif
  236.         case TYLONG:
  237.             x=Ptr->flint;
  238.         xint:    lwrt_I(x);
  239.             break;
  240.         case TYREAL:
  241.             y=Ptr->flreal;
  242.             goto xfloat;
  243.         case TYDREAL:
  244.             y=Ptr->fldouble;
  245.         xfloat: lwrt_F(y);
  246.             break;
  247.         case TYCOMPLEX:
  248.             xx= &Ptr->flreal;
  249.             y = *xx++;
  250.             z = *xx;
  251.             goto xcomplex;
  252.         case TYDCOMPLEX:
  253.             yy = &Ptr->fldouble;
  254.             y= *yy++;
  255.             z = *yy;
  256.         xcomplex:
  257.             lwrt_C(y,z);
  258.             break;
  259.         case TYLOGICAL1:
  260.             x = Ptr->flchar;
  261.             goto xlog;
  262.         case TYLOGICAL2:
  263.             x = Ptr->flshort;
  264.             goto xlog;
  265.         case TYLOGICAL:
  266.             x = Ptr->flint;
  267.         xlog:    lwrt_L(Ptr->flint, len);
  268.             break;
  269.         case TYCHAR:
  270.             lwrt_A(ptr,len);
  271.             break;
  272.         }
  273.         ptr += len;
  274.     }
  275.     return(0);
  276. }
  277.